perm filename TREST.F4[1,MUS] blob
sn#075920 filedate 1973-12-04 generic text, type T, neo UTF8
00100 SUBROUTINE TAIL(RJX,RA,RMINI)
00200 COMMON /STF/RSTFAC(8),RSTJC
00300 COMMON /PLTR/IPLT,RHT,DIS
00400 DIMENSION JARY(1),ITAIL(23)
00500 IF(JARY(1).EQ.0)CALL RDDATA('TAIL',JARY,ITAIL)
00600 CC R=ABS(RA)
00700 Q=-1.
00800 IF(RA)Q=1.
00900 CALL CENTER(RJY)
01000 CALL JDRAW(ITAIL(1),RJX,RJY,RMINI,1.,Q)
01100 1 IF(IPLT.GE.0)RETURN
01200 IF(RMINI.NE.RSTJC)Q=Q*.6
01300 CALL FILLER(ITAIL(ITAIL(1)+2),RJX,RJY,ABS(Q),Q)
01400 CC IF(IPLT)CALL FILLER(ITAIL(ITAIL(1)+2),RJX,RJY,1.,RQ)
01500 C RA=-,STEM UP; RA=+, STEM DOWN.
01600 END
01700
01800 SUBROUTINE REST
01900 COMMON /STF/RSTFAC(8),RSTJC
02000 COMMON /PLTR/IPLT,RHT,DIS
02100 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
02200 EQUIVALENCE(JE,JQ(3))
02300 DIMENSION LRST(4),IRST(74)
02400
02500 IF(LRST(1).EQ.0)CALL RDDATA('REST',LRST,IRST)
02600 L=JE
02700 IF(L.GT.1)L=1
02800 K=LRST(L+3)
02900 C L>3 WHEN SEVERAL TAILS ON REST
03000 CALL CENTER(CENTR)
03100 CALL JDRAW(IRST(K),RJB,CENTR,RSTJC,1.,1.)
03200 IF(JE.OR.IPLT.GE.0)RETURN
03300 CALL FILLER(IRST(IRST(K)+K+1),RJB,CENTR,1.,1.)
03400 C WHY GO THROUGH NOTWRT??
03500 END
03600
03700 SUBROUTINE RDDATA(NM,JARY,IARY)
03800 C READS DATA
03900 DIMENSION JARY(1),IARY(1)
04000 REWIND 23
04100 CALL IFILE(23,NM)
04200 READ(23,5)K,(JARY(K),K=1,10)
04300 N=1
04400 1 READ(23,5,END=2)K,L,(IARY(K),K=N,N+L-1)
04500 N=N+L
04600 GO TO 1
04700 2 RETURN
04800 5 FORMAT(12I)
04900 END
05000
05100 C FOR SINGLE (OR DOUBLE) BAR REPEAT SIGN
05200 SUBROUTINE BREP(RJB,RSTJC)
05300 DIMENSION JREP(1),IREP(36)
05400 IF(JREP(1).EQ.0)CALL RDDATA('BREP',JREP,IREP)
05500 CALL CENTER(R)
05600 CALL JDRAW(IREP,RJB,R,RSTJC,1.,1.)
05700 END
05800
05900 SUBROUTINE FERMTA(RINV)
06000 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
06100 COMMON /PLTR/IPLT,RHT,DIS
06200 COMMON /STF/RSTFAC(8),RSTJC
06300 DIMENSION JFERM(1),IFERM(39)
06400 IF(JFERM(1).EQ.0)CALL RDDATA('FERM',JFERM,IFERM)
06500 CC R=INV
06600 CALL JDRAW(IFERM,RJB,CENTR,RSTJC,1.,RINV)
06700 IF(IPLT)CALL FILLER(IFERM(IFERM(1)+2),RJB,CENTR,1.,RINV)
06800 END
06900
07000 SUBROUTINE EXCH(X,Y)
07100 Z=X
07200 X=Y
07300 Y=Z
07400 END
07500 SUBROUTINE SORT2(RPOS,M)
07600 DIMENSION RPOS(2,200)
07700 L=2
07800 3 J=-1
07900 RX=RPOS(1,L-1)
08000 DO 2 K=L,M
08100 IF(RPOS(1,K).GE.RX)GO TO 2
08200 RX=RPOS(1,K)
08300 C WHY WERE ALL THE RX'S JX ????? 9/6/73
08400 J=K
08500 2 CONTINUE
08600 IF(J)GO TO 4
08700 K=L-1
08800 CALL EXCH(RPOS(1,K),RPOS(1,J))
08900 CALL EXCH(RPOS(2,K),RPOS(2,J))
09000 4 L=L+1
09100 IF(L.LE.M)GO TO 3
09200 END
09300